(defpackage :beads
  (:use :cl)
  (:export :beads-mixin
           :delete-bead-overlay
           :add-bead-overlay
           :find-overlay
           :dump))

(in-package :beads)

(defclass beads-mixin ()
  ())

(defclass beads-overlay (gwee:view)
  ((top :initarg :top :accessor top)
   (bottom :initarg :bottom :accessor bottom)
   (nodes :initarg :nodes :accessor nodes)
   (next-box :initarg :next-box :accessor next-box :documentation
             "The box that should be selected next.")
   (points :accessor points)
   (circles :accessor circles)))

(defun add-segments (points segment-length)
  (loop for rest on points
     for first = (first rest)
     for next = (second rest)
     while next
     append (loop
               with extra-circles = (truncate (u:distance first next) segment-length)
               with xdelta = (- (first next) (first first))
               with xstep = (if (zerop extra-circles)
                                0
                                (/ xdelta extra-circles))
               with ydelta = (- (second next) (second first))
               with ystep = (if (zerop extra-circles)
                                0
                                (/ ydelta extra-circles))
               for x = (first first) then (+ x xstep)
               for y = (second first) then (+ y ystep)
               for i below extra-circles
               collect (list (truncate x) (truncate y)))))

(defun find-missing-nodes (bottom boxes)
  "Given a list of boxes to select, calculate the missing argument
nodes that are needed to create the loop."
  (loop for b in boxes
       if (eq b bottom)
       append (u:collect-if (complement 'd:quantity) (tree:children b))
       else
       collect (find-if-not 'd:quantity (tree:children b))))

(defun calculate-points (view)
  (let ((points (list (list (geom:centerx (top view)) (geom:bottom (top view)))))
        circles
        sides)
    (labels ((walk (arg child)
               (let ((box (tree:parent arg)))
                 (when (> (- (geom:y arg) (geom:bottom child)) 25)
                   (push (list (geom:centerx arg) (+ (geom:bottom child) 20)) points))
                 (push (list (geom:centerx arg) (geom:y arg)) points)
                 (push (list (if (< (geom:centerx box) (geom:centerx arg))
                                 (- (geom:centerx arg) 3)
                                 (+ (geom:centerx arg) 3))
                             (geom:centery arg)) points)
                 (push (list (geom:centerx box) (+ (geom:centery box) 6)) points)
                 (push (list (geom:centerx arg) (geom:centery arg)) circles)
                 (unless (eq box (bottom view))
                   (push (list (geom:centerx box) (geom:bottom box)) points))
                 (if (eq box (bottom view))
                     (progn
                       (push points sides)
                       (setf points (list (list (geom:centerx (top view)) (geom:bottom (top view))))))
                     (mapc (u:curry walk (arg) box)
                           (u:collect-with (a (tree:parents box))
                             (find a (nodes view))))))))
      (mapc (lambda (arg)
              (walk arg (top view)))
            (u:collect-with (a (tree:parents (top view)))
              (find a (nodes view))))
      (setf (points view) (add-segments (append (first sides)
                                                (reverse (second sides)))
                                        8)
            (circles view) circles))))

(defmethod shared-initialize :after ((obj beads-overlay) slots &key (boxes nil suppliedp))
  (when suppliedp
    (setf (nodes obj) (append boxes (find-missing-nodes (bottom obj) boxes))))
  (calculate-points obj))

(defmethod gwee:draw-view ((view beads-overlay))
  (dolist (p (points view))
    (gwee:draw-circle view (first p) (second p) 2
                      :color (sdl:color :g 150 :a 200)
                      :filled t))
    (dolist (c (circles view))
      (gwee:draw-circle view (first c) (second c) 12
                        :color (sdl:color :g 150 :a 100)
                        :filled t))
  ;; (gwee:draw-polygon view points
  ;;                    :color (sdl:color :g 255 :a 100))
  )

(defun delete-bead-overlay (diagram)
  (gwee:delete-views-if (lambda (view)
                          (typep view 'beads-overlay))
                        diagram))

(defun add-bead-overlay (diagram selection next-box)
  (delete-bead-overlay diagram)
  (let ((top (lt:find-top-box (d:root diagram) selection))
        (bottom (lt:find-bottom-box (d:root diagram) selection)))
    (assert bottom)
    (assert top)
    (make-instance 'beads-overlay
                   :top top
                   :bottom bottom
                   :boxes selection
                   :next-box next-box
                   :parent diagram)))

(defun find-overlay (diagram)
  (find-if (lambda (v)
             (typep v 'beads-overlay))
           (gwee:view-subviews diagram)))

(defun dump (bead)
  (list* :o
         ;;(dgraph:gen-id (top bead))
         (mapcar 'dgraph:gen-id (nodes bead))))
